home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / lib / srfi-43.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  56.8 KB  |  1,331 lines
  1. ;;;;;; SRFI 43: Vector library                           -*- Scheme -*-
  2.  
  3. ;;; Taylor Campbell wrote this code; he places it in the public domain.
  4.  
  5.  
  6. ;; ChangeLog
  7. ;;
  8. ;; 2007-08-28 yamaken   - Imported from
  9. ;;                        http://srfi.schemers.org/srfi-43/vector-lib.scm
  10. ;;                        and adapted to SigScheme
  11. ;; 2007-09-08 yamaken   - Fix an incorrect error message in check-indices
  12.  
  13.  
  14. ;;; --------------------
  15. ;;; Exported procedure index
  16. ;;;
  17. ;;; * Constructors
  18. ;;; make-vector vector
  19. ;;; vector-unfold                   vector-unfold-right
  20. ;;; vector-copy                     vector-reverse-copy
  21. ;;; vector-append                   vector-concatenate
  22. ;;;
  23. ;;; * Predicates
  24. ;;; vector?
  25. ;;; vector-empty?
  26. ;;; vector=
  27. ;;;
  28. ;;; * Selectors
  29. ;;; vector-ref
  30. ;;; vector-length
  31. ;;;
  32. ;;; * Iteration
  33. ;;; vector-fold                     vector-fold-right
  34. ;;; vector-map                      vector-map!
  35. ;;; vector-for-each
  36. ;;; vector-count
  37. ;;;
  38. ;;; * Searching
  39. ;;; vector-index                    vector-skip
  40. ;;; vector-index-right              vector-skip-right
  41. ;;; vector-binary-search
  42. ;;; vector-any                      vector-every
  43. ;;;
  44. ;;; * Mutators
  45. ;;; vector-set!
  46. ;;; vector-swap!
  47. ;;; vector-fill!
  48. ;;; vector-reverse!
  49. ;;; vector-copy!                    vector-reverse-copy!
  50. ;;; vector-reverse!
  51. ;;;
  52. ;;; * Conversion
  53. ;;; vector->list                    reverse-vector->list
  54. ;;; list->vector                    reverse-list->vector
  55.  
  56.  
  57.  
  58. ;;; --------------------
  59. ;;; Commentary on efficiency of the code
  60.  
  61. ;;; This code is somewhat tuned for efficiency.  There are several
  62. ;;; internal routines that can be optimized greatly to greatly improve
  63. ;;; the performance of much of the library.  These internal procedures
  64. ;;; are already carefully tuned for performance, and lambda-lifted by
  65. ;;; hand.  Some other routines are lambda-lifted by hand, but only the
  66. ;;; loops are lambda-lifted, and only if some routine has two possible
  67. ;;; loops -- a fast path and an n-ary case --, whereas _all_ of the
  68. ;;; internal routines' loops are lambda-lifted so as to never cons a
  69. ;;; closure in their body (VECTOR-PARSE-START+END doesn't have a loop),
  70. ;;; even in Scheme systems that perform no loop optimization (which is
  71. ;;; most of them, unfortunately).
  72. ;;;
  73. ;;; Fast paths are provided for common cases in most of the loops in
  74. ;;; this library.
  75. ;;;
  76. ;;; All calls to primitive vector operations are protected by a prior
  77. ;;; type check; they can be safely converted to use unsafe equivalents
  78. ;;; of the operations, if available.  Ideally, the compiler should be
  79. ;;; able to determine this, but the state of Scheme compilers today is
  80. ;;; not a happy one.
  81. ;;;
  82. ;;; Efficiency of the actual algorithms is a rather mundane point to
  83. ;;; mention; vector operations are rarely beyond being straightforward.
  84.  
  85.  
  86.  
  87. ;;; --------------------
  88. ;;; Utilities
  89.  
  90. ;;; SigScheme: Use native SRFI-8
  91. ;;;;; SRFI 8, too trivial to put in the dependencies list.
  92. ;;(define-syntax receive
  93. ;;  (syntax-rules ()
  94. ;;    ((receive ?formals ?producer ?body1 ?body2 ...)
  95. ;;     (call-with-values (lambda () ?producer)
  96. ;;       (lambda ?formals ?body1 ?body2 ...)))))
  97.  
  98. ;;; SigScheme: Define let*-optionals as an alias to let-optionals*
  99. ;;;;; Not the best LET*-OPTIONALS, but not the worst, either.  Use Olin's
  100. ;;;;; if it's available to you.
  101. ;;(define-syntax let*-optionals
  102. ;;  (syntax-rules ()
  103. ;;    ((let*-optionals (?x ...) ((?var ?default) ...) ?body1 ?body2 ...)
  104. ;;     (let ((args (?x ...)))
  105. ;;       (let*-optionals args ((?var ?default) ...) ?body1 ?body2 ...)))
  106. ;;    ((let*-optionals ?args ((?var ?default) ...) ?body1 ?body2 ...)
  107. ;;     (let*-optionals:aux ?args ?args ((?var ?default) ...)
  108. ;;       ?body1 ?body2 ...))))
  109. ;;
  110. ;;(define-syntax let*-optionals:aux
  111. ;;  (syntax-rules ()
  112. ;;    ((aux ?orig-args-var ?args-var () ?body1 ?body2 ...)
  113. ;;     (if (null? ?args-var)
  114. ;;         (let () ?body1 ?body2 ...)
  115. ;;         (error "too many arguments" (length ?orig-args-var)
  116. ;;                ?orig-args-var)))
  117. ;;    ((aux ?orig-args-var ?args-var
  118. ;;         ((?var ?default) ?more ...)
  119. ;;       ?body1 ?body2 ...)
  120. ;;     (if (null? ?args-var)
  121. ;;         (let* ((?var ?default) ?more ...) ?body1 ?body2 ...)
  122. ;;         (let ((?var (car ?args-var))
  123. ;;               (new-args (cdr ?args-var)))
  124. ;;           (let*-optionals:aux ?orig-args-var new-args
  125. ;;               (?more ...)
  126. ;;             ?body1 ?body2 ...))))))
  127.  
  128. (define (nonneg-int? x)
  129.   (and (integer? x)
  130.        (not (negative? x))))
  131.  
  132. (define (between? x y z)
  133.   (and (<  x y)
  134.        (<= y z)))
  135.  
  136. (define (unspecified-value) (if #f #f))
  137.  
  138. ;++ This should be implemented more efficiently.  It shouldn't cons a
  139. ;++ closure, and the cons cells used in the loops when using this could
  140. ;++ be reused.
  141. (define (vectors-ref vectors i)
  142.   (map (lambda (v) (vector-ref v i)) vectors))
  143.  
  144.  
  145.  
  146. ;;; --------------------
  147. ;;; Error checking
  148.  
  149. ;;; Error signalling (not checking) is done in a way that tries to be
  150. ;;; as helpful to the person who gets the debugging prompt as possible.
  151. ;;; That said, error _checking_ tries to be as unredundant as possible.
  152.  
  153. ;;; I don't use any sort of general condition mechanism; I use simply
  154. ;;; SRFI 23's ERROR, even in cases where it might be better to use such
  155. ;;; a general condition mechanism.  Fix that when porting this to a
  156. ;;; Scheme implementation that has its own condition system.
  157.  
  158. ;;; In argument checks, upon receiving an invalid argument, the checker
  159. ;;; procedure recursively calls itself, but in one of the arguments to
  160. ;;; itself is a call to ERROR; this mechanism is used in the hopes that
  161. ;;; the user may be thrown into a debugger prompt, proceed with another
  162. ;;; value, and let it be checked again.
  163.  
  164. ;;; Type checking is pretty basic, but easily factored out and replaced
  165. ;;; with whatever your implementation's preferred type checking method
  166. ;;; is.  I doubt there will be many other methods of index checking,
  167. ;;; though the index checkers might be better implemented natively.
  168.  
  169. ;;; (CHECK-TYPE <type-predicate?> <value> <callee>) -> value
  170. ;;;   Ensure that VALUE satisfies TYPE-PREDICATE?; if not, signal an
  171. ;;;   error stating that VALUE did not satisfy TYPE-PREDICATE?, showing
  172. ;;;   that this happened while calling CALLEE.  Return VALUE if no
  173. ;;;   error was signalled.
  174. (define (check-type pred? value callee)
  175.   (if (pred? value)
  176.       value
  177.       ;; Recur: when (or if) the user gets a debugger prompt, he can
  178.       ;; proceed where the call to ERROR was with the correct value.
  179.       (check-type pred?
  180.                   (error "erroneous value"
  181.                          (list pred? value)
  182.                          `(while calling ,callee))
  183.                   callee)))
  184.  
  185. ;;; (CHECK-INDEX <vector> <index> <callee>) -> index
  186. ;;;   Ensure that INDEX is a valid index into VECTOR; if not, signal an
  187. ;;;   error stating that it is not and that this happened in a call to
  188. ;;;   CALLEE.  Return INDEX when it is valid.  (Note that this does NOT
  189. ;;;   check that VECTOR is indeed a vector.)
  190. (define (check-index vec index callee)
  191.   (let ((index (check-type integer? index callee)))
  192.     (cond ((< index 0)
  193.            (check-index vec
  194.                         (error "vector index too low"
  195.                                index
  196.                                `(into vector ,vec)
  197.                                `(while calling ,callee))
  198.                         callee))
  199.           ((>= index (vector-length vec))
  200.            (check-index vec
  201.                         (error "vector index too high"
  202.                                index
  203.                                `(into vector ,vec)
  204.                                `(while calling ,callee))
  205.                         callee))
  206.           (else index))))
  207.  
  208. ;;; (CHECK-INDICES <vector>
  209. ;;;                <start> <start-name>
  210. ;;;                <end> <end-name>
  211. ;;;                <caller>) -> [start end]
  212. ;;;   Ensure that START and END are valid bounds of a range within
  213. ;;;   VECTOR; if not, signal an error stating that they are not, with
  214. ;;;   the message being informative about what the argument names were
  215. ;;;   called -- by using START-NAME & END-NAME --, and that it occurred
  216. ;;;   while calling CALLEE.  Also ensure that VEC is in fact a vector.
  217. ;;;   Returns no useful value.
  218. (define (check-indices vec start start-name end end-name callee)
  219.   (let ((lose (lambda things
  220.                 (apply error "vector range out of bounds"
  221.                        (append things
  222.                                `(vector was ,vec)
  223.                                `(,start-name was ,start)
  224.                                `(,end-name was ,end)
  225.                                `(while calling ,callee)))))
  226.         (start (check-type integer? start callee))
  227.         (end   (check-type integer? end   callee)))
  228.     (cond ((> start end)
  229.            ;; I'm not sure how well this will work.  The intent is that
  230.            ;; the programmer tells the debugger to proceed with both a
  231.            ;; new START & a new END by returning multiple values
  232.            ;; somewhere.
  233.            (receive (new-start new-end)
  234.                     (lose `(,end-name < ,start-name))
  235.              (check-indices vec
  236.                             new-start start-name
  237.                             new-end end-name
  238.                             callee)))
  239.           ((< start 0)
  240.            (check-indices vec
  241.                           (lose `(,start-name < 0))
  242.                           start-name
  243.                           end end-name
  244.                           callee))
  245.           ((>= start (vector-length vec))
  246.            (check-indices vec
  247.                           (lose `(,start-name >= len)
  248.                                 `(len was ,(vector-length vec)))
  249.                           start-name
  250.                           end end-name
  251.                           callee))
  252.           ((> end (vector-length vec))
  253.            (check-indices vec
  254.                           start start-name
  255.                           (lose `(,end-name > len)
  256.                                 `(len was ,(vector-length vec)))
  257.                           end-name
  258.                           callee))
  259.           (else
  260.            (values start end)))))
  261.  
  262.  
  263.  
  264. ;;; --------------------
  265. ;;; Internal routines
  266.  
  267. ;;; These should all be integrated, native, or otherwise optimized --
  268. ;;; they're used a _lot_ --.  All of the loops and LETs inside loops
  269. ;;; are lambda-lifted by hand, just so as not to cons closures in the
  270. ;;; loops.  (If your compiler can do better than that if they're not
  271. ;;; lambda-lifted, then lambda-drop (?) them.)
  272.  
  273. ;;; (VECTOR-PARSE-START+END <vector> <arguments>
  274. ;;;                         <start-name> <end-name>
  275. ;;;                         <callee>)
  276. ;;;       -> [start end]
  277. ;;;   Return two values, composing a valid range within VECTOR, as
  278. ;;;   extracted from ARGUMENTS or defaulted from VECTOR -- 0 for START
  279. ;;;   and the length of VECTOR for END --; START-NAME and END-NAME are
  280. ;;;   purely for error checking.
  281. (define (vector-parse-start+end vec args start-name end-name callee)
  282.   (let ((len (vector-length vec)))
  283.     (cond ((null? args)
  284.            (values 0 len))
  285.           ((null? (cdr args))
  286.            (check-indices vec
  287.                           (car args) start-name
  288.                           len end-name
  289.                           callee))
  290.           ((null? (cddr args))
  291.            (check-indices vec
  292.                           (car  args) start-name
  293.                           (cadr args) end-name
  294.                           callee))
  295.           (else
  296.            (error "too many arguments"
  297.                   `(extra args were ,(cddr args))
  298.                   `(while calling ,callee))))))
  299.  
  300. ;;; SigScheme: Defined in module-srfi43.c
  301. ;;(define-syntax let-vector-start+end
  302. ;;  (syntax-rules ()
  303. ;;    ((let-vector-start+end ?callee ?vec ?args (?start ?end)
  304. ;;       ?body1 ?body2 ...)
  305. ;;     (let ((?vec (check-type vector? ?vec ?callee)))
  306. ;;       (receive (?start ?end)
  307. ;;                (vector-parse-start+end ?vec ?args '?start '?end
  308. ;;                                        ?callee)
  309. ;;         ?body1 ?body2 ...)))))
  310.  
  311. ;;; (%SMALLEST-LENGTH <vector-list> <default-length> <callee>)
  312. ;;;       -> exact, nonnegative integer
  313. ;;;   Compute the smallest length of VECTOR-LIST.  DEFAULT-LENGTH is
  314. ;;;   the length that is returned if VECTOR-LIST is empty.  Common use
  315. ;;;   of this is in n-ary vector routines:
  316. ;;;     (define (f vec . vectors)
  317. ;;;       (let ((vec (check-type vector? vec f)))
  318. ;;;         ...(%smallest-length vectors (vector-length vec) f)...))
  319. ;;;   %SMALLEST-LENGTH takes care of the type checking -- which is what
  320. ;;;   the CALLEE argument is for --; thus, the design is tuned for
  321. ;;;   avoiding redundant type checks.
  322. (define %smallest-length
  323.   (letrec ((loop (lambda (vector-list length callee)
  324.                    (if (null? vector-list)
  325.                        length
  326.                        (loop (cdr vector-list)
  327.                              (min (vector-length
  328.                                    (check-type vector?
  329.                                                (car vector-list)
  330.                                                callee))
  331.                                   length)
  332.                              callee)))))
  333.     loop))
  334.  
  335. ;;; (%VECTOR-COPY! <target> <tstart> <source> <sstart> <send>)
  336. ;;;   Copy elements at locations SSTART to SEND from SOURCE to TARGET,
  337. ;;;   starting at TSTART in TARGET.
  338. ;;;
  339. ;;; Optimize this!  Probably with some combination of:
  340. ;;;   - Force it to be integrated.
  341. ;;;   - Let it use unsafe vector element dereferencing routines: bounds
  342. ;;;     checking already happens outside of it.  (Or use a compiler
  343. ;;;     that figures this out, but Olin Shivers' PhD thesis seems to
  344. ;;;     have been largely ignored in actual implementations...)
  345. ;;;   - Implement it natively as a VM primitive: the VM can undoubtedly
  346. ;;;     perform much faster than it can make Scheme perform, even with
  347. ;;;     bounds checking.
  348. ;;;   - Implement it in assembly: you _want_ the fine control that
  349. ;;;     assembly can give you for this.
  350. ;;; I already lambda-lift it by hand, but you should be able to make it
  351. ;;; even better than that.
  352. (define %vector-copy!
  353.   (letrec ((loop/l->r (lambda (target source send i j)
  354.                         (cond ((< i send)
  355.                                (vector-set! target j
  356.                                             (vector-ref source i))
  357.                                (loop/l->r target source send
  358.                                           (+ i 1) (+ j 1))))))
  359.            (loop/r->l (lambda (target source sstart i j)
  360.                         (cond ((>= i sstart)
  361.                                (vector-set! target j
  362.                                             (vector-ref source i))
  363.                                (loop/r->l target source sstart
  364.                                           (- i 1) (- j 1)))))))
  365.     (lambda (target tstart source sstart send)
  366.       (if (> sstart tstart)             ; Make sure we don't copy over
  367.                                         ;   ourselves.
  368.           (loop/l->r target source send sstart tstart)
  369.           (loop/r->l target source sstart (- send 1)
  370.                      (+ -1 tstart send (- sstart)))))))
  371.  
  372. ;;; (%VECTOR-REVERSE-COPY! <target> <tstart> <source> <sstart> <send>)
  373. ;;;   Copy elements from SSTART to SEND from SOURCE to TARGET, in the
  374. ;;;   reverse order.
  375. (define %vector-reverse-copy!
  376.   (letrec ((loop (lambda (target source sstart i j)
  377.                    (cond ((>= i sstart)
  378.                           (vector-set! target j (vector-ref source i))
  379.                           (loop target source sstart
  380.                                 (- i 1)
  381.                                 (+ j 1)))))))
  382.     (lambda (target tstart source sstart send)
  383.       (loop target source sstart
  384.             (- send 1)
  385.             tstart))))
  386.  
  387. ;;; (%VECTOR-REVERSE! <vector>)
  388. (define %vector-reverse!
  389.   (letrec ((loop (lambda (vec i j)
  390.                    (cond ((<= i j)
  391.                           (let ((v (vector-ref vec i)))
  392.                             (vector-set! vec i (vector-ref vec j))
  393.                             (vector-set! vec j v)
  394.                             (loop vec (+ i 1) (- j 1))))))))
  395.     (lambda (vec start end)
  396.       (loop vec start (- end 1)))))
  397.  
  398. ;;; (%VECTOR-FOLD1 <kons> <knil> <vector>) -> knil'
  399. ;;;     (KONS <index> <knil> <elt>) -> knil'
  400. (define %vector-fold1
  401.   (letrec ((loop (lambda (kons knil len vec i)
  402.                    (if (= i len)
  403.                        knil
  404.                        (loop kons
  405.                              (kons i knil (vector-ref vec i))
  406.                              len vec (+ i 1))))))
  407.     (lambda (kons knil len vec)
  408.       (loop kons knil len vec 0))))
  409.  
  410. ;;; (%VECTOR-FOLD2+ <kons> <knil> <vector> ...) -> knil'
  411. ;;;     (KONS <index> <knil> <elt> ...) -> knil'
  412. (define %vector-fold2+
  413.   (letrec ((loop (lambda (kons knil len vectors i)
  414.                    (if (= i len)
  415.                        knil
  416.                        (loop kons
  417.                              (apply kons i knil
  418.                                     (vectors-ref vectors i))
  419.                              len vectors (+ i 1))))))
  420.     (lambda (kons knil len vectors)
  421.       (loop kons knil len vectors 0))))
  422.  
  423. ;;; (%VECTOR-MAP! <f> <target> <length> <vector>) -> target
  424. ;;;     (F <index> <elt>) -> elt'
  425. (define %vector-map1!
  426.   (letrec ((loop (lambda (f target vec i)
  427.                    (if (zero? i)
  428.                        target
  429.                        (let ((j (- i 1)))
  430.                          (vector-set! target j
  431.                                       (f j (vector-ref vec j)))
  432.                          (loop f target vec j))))))
  433.     (lambda (f target vec len)
  434.       (loop f target vec len))))
  435.  
  436. ;;; (%VECTOR-MAP2+! <f> <target> <vectors> <len>) -> target
  437. ;;;     (F <index> <elt> ...) -> elt'
  438. (define %vector-map2+!
  439.   (letrec ((loop (lambda (f target vectors i)
  440.                    (if (zero? i)
  441.                        target
  442.                        (let ((j (- i 1)))
  443.                          (vector-set! target j
  444.                            (apply f j (vectors-ref vectors j)))
  445.                          (loop f target vectors j))))))
  446.     (lambda (f target vectors len)
  447.       (loop f target vectors len))))
  448.  
  449.  
  450.  
  451. ;;;;;;;;;;;;;;;;;;;;;;;; ***** vector-lib ***** ;;;;;;;;;;;;;;;;;;;;;;;
  452.  
  453. ;;; --------------------
  454. ;;; Constructors
  455.  
  456. ;;; (MAKE-VECTOR <size> [<fill>]) -> vector
  457. ;;;   [R5RS] Create a vector of length LENGTH.  If FILL is present,
  458. ;;;   initialize each slot in the vector with it; if not, the vector's
  459. ;;;   initial contents are unspecified.
  460. (define make-vector make-vector)
  461.  
  462. ;;; (VECTOR <elt> ...) -> vector
  463. ;;;   [R5RS] Create a vector containing ELEMENT ..., in order.
  464. (define vector vector)
  465.  
  466. ;;; This ought to be able to be implemented much more efficiently -- if
  467. ;;; we have the number of arguments available to us, we can create the
  468. ;;; vector without using LENGTH to determine the number of elements it
  469. ;;; should have.
  470. ;(define (vector . elements) (list->vector elements))
  471.  
  472. ;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector
  473. ;;;     (F <index> <seed> ...) -> [elt seed' ...]
  474. ;;;   The fundamental vector constructor.  Creates a vector whose
  475. ;;;   length is LENGTH and iterates across each index K between 0 and
  476. ;;;   LENGTH, applying F at each iteration to the current index and the
  477. ;;;   current seeds to receive N+1 values: first, the element to put in
  478. ;;;   the Kth slot and then N new seeds for the next iteration.
  479. (define vector-unfold
  480.   (letrec ((tabulate!                   ; Special zero-seed case.
  481.             (lambda (f vec i len)
  482.               (cond ((< i len)
  483.                      (vector-set! vec i (f i))
  484.                      (tabulate! f vec (+ i 1) len)))))
  485.            (unfold1!                    ; Fast path for one seed.
  486.             (lambda (f vec i len seed)
  487.               (if (< i len)
  488.                   (receive (elt new-seed)
  489.                            (f i seed)
  490.                     (vector-set! vec i elt)
  491.                     (unfold1! f vec (+ i 1) len new-seed)))))
  492.            (unfold2+!                   ; Slower variant for N seeds.
  493.             (lambda (f vec i len seeds)
  494.               (if (< i len)
  495.                   (receive (elt . new-seeds)
  496.                            (apply f i seeds)
  497.                     (vector-set! vec i elt)
  498.                     (unfold2+! f vec (+ i 1) len new-seeds))))))
  499.     (lambda (f len . initial-seeds)
  500.       (let ((f   (check-type procedure?  f   vector-unfold))
  501.             (len (check-type nonneg-int? len vector-unfold)))
  502.         (let ((vec (make-vector len)))
  503.           (cond ((null? initial-seeds)
  504.                  (tabulate! f vec 0 len))
  505.                 ((null? (cdr initial-seeds))
  506.                  (unfold1! f vec 0 len (car initial-seeds)))
  507.                 (else
  508.                  (unfold2+! f vec 0 len initial-seeds)))
  509.           vec)))))
  510.  
  511. ;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector
  512. ;;;     (F <seed> ...) -> [seed' ...]
  513. ;;;   Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0
  514. ;;;   (still exclusive with  LENGTH and inclusive with 0), not 0 to
  515. ;;;   LENGTH as with VECTOR-UNFOLD.
  516. (define vector-unfold-right
  517.   (letrec ((tabulate!
  518.             (lambda (f vec i)
  519.               (cond ((>= i 0)
  520.                      (vector-set! vec i (f i))
  521.                      (tabulate! f vec (- i 1))))))
  522.            (unfold1!
  523.             (lambda (f vec i seed)
  524.               (if (>= i 0)
  525.                   (receive (elt new-seed)
  526.                            (f i seed)
  527.                     (vector-set! vec i elt)
  528.                     (unfold1! f vec (- i 1) new-seed)))))
  529.            (unfold2+!
  530.             (lambda (f vec i seeds)
  531.               (if (>= i 0)
  532.                   (receive (elt . new-seeds)
  533.                            (apply f i seeds)
  534.                     (vector-set! vec i elt)
  535.                     (unfold2+! f vec (- i 1) new-seeds))))))
  536.     (lambda (f len . initial-seeds)
  537.       (let ((f   (check-type procedure?  f   vector-unfold-right))
  538.             (len (check-type nonneg-int? len vector-unfold-right)))
  539.         (let ((vec (make-vector len))
  540.               (i (- len 1)))
  541.           (cond ((null? initial-seeds)
  542.                  (tabulate! f vec i))
  543.                 ((null? (cdr initial-seeds))
  544.                  (unfold1!  f vec i (car initial-seeds)))
  545.                 (else
  546.                  (unfold2+! f vec i initial-seeds)))
  547.           vec)))))
  548.  
  549. ;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector
  550. ;;;   Create a newly allocated vector containing the elements from the
  551. ;;;   range [START,END) in VECTOR.  START defaults to 0; END defaults
  552. ;;;   to the length of VECTOR.  END may be greater than the length of
  553. ;;;   VECTOR, in which case the vector is enlarged; if FILL is passed,
  554. ;;;   the new locations from which there is no respective element in
  555. ;;;   VECTOR are filled with FILL.
  556. (define (vector-copy vec . args)
  557.   (let ((vec (check-type vector? vec vector-copy)))
  558.     ;; We can't use LET-VECTOR-START+END, because we have one more
  559.     ;; argument, and we want finer control, too.
  560.     ;;
  561.     ;; Olin's implementation of LET*-OPTIONALS would prove useful here:
  562.     ;; the built-in argument-checks-as-you-go-along produces almost
  563.     ;; _exactly_ the same code as VECTOR-COPY:PARSE-ARGS.
  564.     (receive (start end fill)
  565.              (vector-copy:parse-args vec args)
  566.       (let ((new-vector (make-vector (- end start) fill)))
  567.         (%vector-copy! new-vector 0
  568.                        vec        start
  569.                        (if (> end (vector-length vec))
  570.                            (vector-length vec)
  571.                            end))
  572.         new-vector))))
  573.  
  574. ;;; Auxiliary for VECTOR-COPY.
  575. (define (vector-copy:parse-args vec args)
  576.   (if (null? args)
  577.       (values 0 (vector-length vec) (unspecified-value))
  578.       (let ((start (check-index vec (car args) vector-copy)))
  579.         (if (null? (cdr args))
  580.             (values start (vector-length vec) (unspecified-value))
  581.             (let ((end (check-type nonneg-int? (cadr args)
  582.                                    vector-copy)))
  583.               (cond ((>= start (vector-length vec))
  584.                      (error "start bound out of bounds"
  585.                             `(start was ,start)
  586.                             `(end was ,end)
  587.                             `(vector was ,vec)
  588.                             `(while calling ,vector-copy)))
  589.                     ((> start end)
  590.                      (error "can't invert a vector copy!"
  591.                             `(start was ,start)
  592.                             `(end was ,end)
  593.                             `(vector was ,vec)
  594.                             `(while calling ,vector-copy)))
  595.                     ((null? (cddr args))
  596.                      (values start end (unspecified-value)))
  597.                     (else
  598.                      (let ((fill (caddr args)))
  599.                        (if (null? (cdddr args))
  600.                            (values start end fill)
  601.                            (error "too many arguments"
  602.                                   vector-copy
  603.                                   (cdddr args)))))))))))
  604.  
  605. ;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector
  606. ;;;   Create a newly allocated vector whose elements are the reversed
  607. ;;;   sequence of elements between START and END in VECTOR.  START's
  608. ;;;   default is 0; END's default is the length of VECTOR.
  609. (define (vector-reverse-copy vec . maybe-start+end)
  610.   (let-vector-start+end vector-reverse-copy vec maybe-start+end
  611.                         (start end)
  612.     (let ((new (make-vector (- end start))))
  613.       (%vector-reverse-copy! new 0 vec start end)
  614.       new)))
  615.  
  616. ;;; (VECTOR-APPEND <vector> ...) -> vector
  617. ;;;   Append VECTOR ... into a newly allocated vector and return that
  618. ;;;   new vector.
  619. (define (vector-append . vectors)
  620.   (vector-concatenate:aux vectors vector-append))
  621.  
  622. ;;; (VECTOR-CONCATENATE <vector-list>) -> vector
  623. ;;;   Concatenate the vectors in VECTOR-LIST.  This is equivalent to
  624. ;;;     (apply vector-append VECTOR-LIST)
  625. ;;;   but VECTOR-APPEND tends to be implemented in terms of
  626. ;;;   VECTOR-CONCATENATE, and some Schemes bork when the list to apply
  627. ;;;   a function to is too long.
  628. ;;;
  629. ;;; Actually, they're both implemented in terms of an internal routine.
  630. (define (vector-concatenate vector-list)
  631.   (vector-concatenate:aux vector-list vector-concatenate))
  632.  
  633. ;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE
  634. (define vector-concatenate:aux
  635.   (letrec ((compute-length
  636.             (lambda (vectors len callee)
  637.               (if (null? vectors)
  638.                   len
  639.                   (let ((vec (check-type vector? (car vectors)
  640.                                          callee)))
  641.                     (compute-length (cdr vectors)
  642.                                     (+ (vector-length vec) len)
  643.                                     callee)))))
  644.            (concatenate!
  645.             (lambda (vectors target to)
  646.               (if (null? vectors)
  647.                   target
  648.                   (let* ((vec1 (car vectors))
  649.                          (len (vector-length vec1)))
  650.                     (%vector-copy! target to vec1 0 len)
  651.                     (concatenate! (cdr vectors) target
  652.                                   (+ to len)))))))
  653.     (lambda (vectors callee)
  654.       (cond ((null? vectors)            ;+++
  655.              (make-vector 0))
  656.             ((null? (cdr vectors))      ;+++
  657.              ;; Blech, we still have to allocate a new one.
  658.              (let* ((vec (check-type vector? (car vectors) callee))
  659.                     (len (vector-length vec))
  660.                     (new (make-vector len)))
  661.                (%vector-copy! new 0 vec 0 len)
  662.                new))
  663.             (else
  664.              (let ((new-vector
  665.                     (make-vector (compute-length vectors 0 callee))))
  666.                (concatenate! vectors new-vector 0)
  667.                new-vector))))))
  668.  
  669.  
  670.  
  671. ;;; --------------------
  672. ;;; Predicates
  673.  
  674. ;;; (VECTOR? <value>) -> boolean
  675. ;;;   [R5RS] Return #T if VALUE is a vector and #F if not.
  676. (define vector? vector?)
  677.  
  678. ;;; (VECTOR-EMPTY? <vector>) -> boolean
  679. ;;;   Return #T if VECTOR has zero elements in it, i.e. VECTOR's length
  680. ;;;   is 0, and #F if not.
  681. (define (vector-empty? vec)
  682.   (let ((vec (check-type vector? vec vector-empty?)))
  683.     (zero? (vector-length vec))))
  684.  
  685. ;;; (VECTOR= <elt=?> <vector> ...) -> boolean
  686. ;;;     (ELT=? <value> <value>) -> boolean
  687. ;;;   Determine vector equality generalized across element comparators.
  688. ;;;   Vectors A and B are equal iff their lengths are the same and for
  689. ;;;   each respective elements E_a and E_b (element=? E_a E_b) returns
  690. ;;;   a true value.  ELT=? is always applied to two arguments.  Element
  691. ;;;   comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b)
  692. ;;;   results in a true value, then (ELEMENT=? E_a E_b) must result in a
  693. ;;;   true value.  This may be exploited to avoid multiple unnecessary
  694. ;;;   element comparisons.  (This implementation does, but does not deal
  695. ;;;   with the situation that ELEMENT=? is EQ? to avoid more unnecessary
  696. ;;;   comparisons, but I believe this optimization is probably fairly
  697. ;;;   insignificant.)
  698. ;;;   
  699. ;;;   If the number of vector arguments is zero or one, then #T is
  700. ;;;   automatically returned.  If there are N vector arguments,
  701. ;;;   VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are
  702. ;;;   compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N
  703. ;;;   are compared.  The precise order in which ELT=? is applied is not
  704. ;;;   specified.
  705. (define (vector= elt=? . vectors)
  706.   (let ((elt=? (check-type procedure? elt=? vector=)))
  707.     (cond ((null? vectors)
  708.            #t)
  709.           ((null? (cdr vectors))
  710.            (check-type vector? (car vectors) vector=)
  711.            #t)
  712.           (else
  713.            (let loop ((vecs vectors))
  714.              (let ((vec1 (check-type vector? (car vecs) vector=))
  715.                    (vec2+ (cdr vecs)))
  716.                (or (null? vec2+)
  717.                    (and (binary-vector= elt=? vec1 (car vec2+))
  718.                         (loop vec2+)))))))))
  719. (define (binary-vector= elt=? vector-a vector-b)
  720.   (or (eq? vector-a vector-b)           ;+++
  721.       (let ((length-a (vector-length vector-a))
  722.             (length-b (vector-length vector-b)))
  723.         (letrec ((loop (lambda (i)
  724.                          (or (= i length-a)
  725.                              (and (< i length-b)
  726.                                   (test (vector-ref vector-a i)
  727.                                         (vector-ref vector-b i)
  728.                                         i)))))
  729.                  (test (lambda (elt-a elt-b i)
  730.                          (and (or (eq? elt-a elt-b) ;+++
  731.                                   (elt=? elt-a elt-b))
  732.                               (loop (+ i 1))))))
  733.           (and (= length-a length-b)
  734.                (loop 0))))))
  735.  
  736.  
  737.  
  738. ;;; --------------------
  739. ;;; Selectors
  740.  
  741. ;;; (VECTOR-REF <vector> <index>) -> value
  742. ;;;   [R5RS] Return the value that the location in VECTOR at INDEX is
  743. ;;;   mapped to in the store.
  744. (define vector-ref vector-ref)
  745.  
  746. ;;; (VECTOR-LENGTH <vector>) -> exact, nonnegative integer
  747. ;;;   [R5RS] Return the length of VECTOR.
  748. (define vector-length vector-length)
  749.  
  750.  
  751.  
  752. ;;; --------------------
  753. ;;; Iteration
  754.  
  755. ;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil
  756. ;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args
  757. ;;;   The fundamental vector iterator.  KONS is iterated over each
  758. ;;;   index in all of the vectors in parallel, stopping at the end of
  759. ;;;   the shortest; KONS is applied to an argument list of (list I
  760. ;;;   STATE (vector-ref VEC I) ...), where STATE is the current state
  761. ;;;   value -- the state value begins with KNIL and becomes whatever
  762. ;;;   KONS returned at the respective iteration --, and I is the
  763. ;;;   current index in the iteration.  The iteration is strictly left-
  764. ;;;   to-right.
  765. ;;;     (vector-fold KONS KNIL (vector E_1 E_2 ... E_N))
  766. ;;;       <=>
  767. ;;;     (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N)
  768. (define (vector-fold kons knil vec . vectors)
  769.   (let ((kons (check-type procedure? kons vector-fold))
  770.         (vec  (check-type vector?    vec  vector-fold)))
  771.     (if (null? vectors)
  772.         (%vector-fold1 kons knil (vector-length vec) vec)
  773.         (%vector-fold2+ kons knil
  774.                         (%smallest-length vectors
  775.                                           (vector-length vec)
  776.                                           vector-fold)
  777.                         (cons vec vectors)))))
  778.  
  779. ;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil
  780. ;;;     (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args
  781. ;;;   The fundamental vector recursor.  Iterates in parallel across
  782. ;;;   VECTOR ... right to left, applying KONS to the elements and the
  783. ;;;   current state value; the state value becomes what KONS returns
  784. ;;;   at each next iteration.  KNIL is the initial state value.
  785. ;;;     (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N))
  786. ;;;       <=>
  787. ;;;     (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1)
  788. ;;;
  789. ;;; Not implemented in terms of a more primitive operations that might
  790. ;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very
  791. ;;; useful elsewhere.
  792. (define vector-fold-right
  793.   (letrec ((loop1 (lambda (kons knil vec i)
  794.                     (if (negative? i)
  795.                         knil
  796.                         (loop1 kons (kons i knil (vector-ref vec i))
  797.                                vec
  798.                                (- i 1)))))
  799.            (loop2+ (lambda (kons knil vectors i)
  800.                      (if (negative? i)
  801.                          knil
  802.                          (loop2+ kons
  803.                                  (apply kons i knil
  804.                                         (vectors-ref vectors i))
  805.                                  vectors
  806.                                  (- i 1))))))
  807.     (lambda (kons knil vec . vectors)
  808.       (let ((kons (check-type procedure? kons vector-fold-right))
  809.             (vec  (check-type vector?    vec  vector-fold-right)))
  810.         (if (null? vectors)
  811.             (loop1  kons knil vec (- (vector-length vec) 1))
  812.             (loop2+ kons knil (cons vec vectors)
  813.                     (- (%smallest-length vectors
  814.                                          (vector-length vec)
  815.                                          vector-fold-right)
  816.                        1)))))))
  817.  
  818. ;;; (VECTOR-MAP <f> <vector> ...) -> vector
  819. ;;;     (F <elt> ...) -> value ; N vectors -> N args
  820. ;;;   Constructs a new vector of the shortest length of the vector
  821. ;;;   arguments.  Each element at index I of the new vector is mapped
  822. ;;;   from the old vectors by (F I (vector-ref VECTOR I) ...).  The
  823. ;;;   dynamic order of application of F is unspecified.
  824. (define (vector-map f vec . vectors)
  825.   (let ((f   (check-type procedure? f   vector-map))
  826.         (vec (check-type vector?    vec vector-map)))
  827.     (if (null? vectors)
  828.         (let ((len (vector-length vec)))
  829.           (%vector-map1! f (make-vector len) vec len))
  830.         (let ((len (%smallest-length vectors
  831.                                      (vector-length vec)
  832.                                      vector-map)))
  833.           (%vector-map2+! f (make-vector len) (cons vec vectors)
  834.                           len)))))
  835.  
  836. ;;; (VECTOR-MAP! <f> <vector> ...) -> unspecified
  837. ;;;     (F <elt> ...) -> element' ; N vectors -> N args
  838. ;;;   Similar to VECTOR-MAP, but rather than mapping the new elements
  839. ;;;   into a new vector, the new mapped elements are destructively
  840. ;;;   inserted into the first vector.  Again, the dynamic order of
  841. ;;;   application of F is unspecified, so it is dangerous for F to
  842. ;;;   manipulate the first VECTOR.
  843. (define (vector-map! f vec . vectors)
  844.   (let ((f   (check-type procedure? f   vector-map!))
  845.         (vec (check-type vector?    vec vector-map!)))
  846.     (if (null? vectors)
  847.         (%vector-map1!  f vec vec (vector-length vec))
  848.         (%vector-map2+! f vec (cons vec vectors)
  849.                         (%smallest-length vectors
  850.                                           (vector-length vec)
  851.                                           vector-map!)))
  852.     (unspecified-value)))
  853.  
  854. ;;; (VECTOR-FOR-EACH <f> <vector> ...) -> unspecified
  855. ;;;     (F <elt> ...) ; N vectors -> N args
  856. ;;;   Simple vector iterator: applies F to each index in the range [0,
  857. ;;;   LENGTH), where LENGTH is the length of the smallest vector
  858. ;;;   argument passed, and the respective element at that index.  In
  859. ;;;   contrast with VECTOR-MAP, F is reliably applied to each
  860. ;;;   subsequent elements, starting at index 0 from left to right, in
  861. ;;;   the vectors.
  862. (define vector-for-each
  863.   (letrec ((for-each1
  864.             (lambda (f vec i len)
  865.               (cond ((< i len)
  866.                      (f i (vector-ref vec i))
  867.                      (for-each1 f vec (+ i 1) len)))))
  868.            (for-each2+
  869.             (lambda (f vecs i len)
  870.               (cond ((< i len)
  871.                      (apply f i (vectors-ref vecs i))
  872.                      (for-each2+ f vecs (+ i 1) len))))))
  873.     (lambda (f vec . vectors)
  874.       (let ((f   (check-type procedure? f   vector-for-each))
  875.             (vec (check-type vector?    vec vector-for-each)))
  876.         (if (null? vectors)
  877.             (for-each1 f vec 0 (vector-length vec))
  878.             (for-each2+ f (cons vec vectors) 0
  879.                         (%smallest-length vectors
  880.                                           (vector-length vec)
  881.                                           vector-for-each)))))))
  882.  
  883. ;;; (VECTOR-COUNT <predicate?> <vector> ...)
  884. ;;;       -> exact, nonnegative integer
  885. ;;;     (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args
  886. ;;;   PREDICATE? is applied element-wise to the elements of VECTOR ...,
  887. ;;;   and a count is tallied of the number of elements for which a
  888. ;;;   true value is produced by PREDICATE?.  This count is returned.
  889. (define (vector-count pred? vec . vectors)
  890.   (let ((pred? (check-type procedure? pred? vector-count))
  891.         (vec   (check-type vector?    vec   vector-count)))
  892.     (if (null? vectors)
  893.         (%vector-fold1 (lambda (index count elt)
  894.                          (if (pred? index elt)
  895.                              (+ count 1)
  896.                              count))
  897.                        0
  898.                        (vector-length vec)
  899.                        vec)
  900.         (%vector-fold2+ (lambda (index count . elts)
  901.                           (if (apply pred? index elts)
  902.                               (+ count 1)
  903.                               count))
  904.                         0
  905.                         (%smallest-length vectors
  906.                                           (vector-length vec)
  907.                                           vector-count)
  908.                         (cons vec vectors)))))
  909.  
  910.  
  911.  
  912. ;;; --------------------
  913. ;;; Searching
  914.  
  915. ;;; (VECTOR-INDEX <predicate?> <vector> ...)
  916. ;;;       -> exact, nonnegative integer or #F
  917. ;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
  918. ;;;   Search left-to-right across VECTOR ... in parallel, returning the
  919. ;;;   index of the first set of values VALUE ... such that (PREDICATE?
  920. ;;;   VALUE ...) returns a true value; if no such set of elements is
  921. ;;;   reached, return #F.
  922. (define (vector-index pred? vec . vectors)
  923.   (vector-index/skip pred? vec vectors vector-index))
  924.  
  925. ;;; (VECTOR-SKIP <predicate?> <vector> ...)
  926. ;;;       -> exact, nonnegative integer or #F
  927. ;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
  928. ;;;   (vector-index (lambda elts (not (apply PREDICATE? elts)))
  929. ;;;                 VECTOR ...)
  930. ;;;   Like VECTOR-INDEX, but find the index of the first set of values
  931. ;;;   that do _not_ satisfy PREDICATE?.
  932. (define (vector-skip pred? vec . vectors)
  933.   (vector-index/skip (lambda elts (not (apply pred? elts)))
  934.                      vec vectors
  935.                      vector-skip))
  936.  
  937. ;;; Auxiliary for VECTOR-INDEX & VECTOR-SKIP
  938. (define vector-index/skip
  939.   (letrec ((loop1  (lambda (pred? vec len i)
  940.                      (cond ((= i len) #f)
  941.                            ((pred? (vector-ref vec i)) i)
  942.                            (else (loop1 pred? vec len (+ i 1))))))
  943.            (loop2+ (lambda (pred? vectors len i)
  944.                      (cond ((= i len) #f)
  945.                            ((apply pred? (vectors-ref vectors i)) i)
  946.                            (else (loop2+ pred? vectors len
  947.                                          (+ i 1)))))))
  948.     (lambda (pred? vec vectors callee)
  949.       (let ((pred? (check-type procedure? pred? callee))
  950.             (vec   (check-type vector?    vec   callee)))
  951.         (if (null? vectors)
  952.             (loop1 pred? vec (vector-length vec) 0)
  953.             (loop2+ pred? (cons vec vectors)
  954.                     (%smallest-length vectors
  955.                                       (vector-length vec)
  956.                                       callee)
  957.                     0))))))
  958.  
  959. ;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...)
  960. ;;;       -> exact, nonnegative integer or #F
  961. ;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
  962. ;;;   Right-to-left variant of VECTOR-INDEX.
  963. (define (vector-index-right pred? vec . vectors)
  964.   (vector-index/skip-right pred? vec vectors vector-index-right))
  965.  
  966. ;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...)
  967. ;;;       -> exact, nonnegative integer or #F
  968. ;;;     (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args
  969. ;;;   Right-to-left variant of VECTOR-SKIP.
  970. (define (vector-skip-right pred? vec . vectors)
  971.   (vector-index/skip-right (lambda elts (not (apply pred? elts)))
  972.                            vec vectors
  973.                            vector-index-right))
  974.  
  975. (define vector-index/skip-right
  976.   (letrec ((loop1  (lambda (pred? vec i)
  977.                      (cond ((negative? i) #f)
  978.                            ((pred? (vector-ref vec i)) i)
  979.                            (else (loop1 pred? vec (- i 1))))))
  980.            (loop2+ (lambda (pred? vectors i)
  981.                      (cond ((negative? i) #f)
  982.                            ((apply pred? (vectors-ref vectors i)) i)
  983.                            (else (loop2+ pred? vectors (- i 1)))))))
  984.     (lambda (pred? vec vectors callee)
  985.       (let ((pred? (check-type procedure? pred? callee))
  986.             (vec   (check-type vector?    vec   callee)))
  987.         (if (null? vectors)
  988.             (loop1 pred? vec (- (vector-length vec) 1))
  989.             (loop2+ pred? (cons vec vectors)
  990.                     (- (%smallest-length vectors
  991.                                          (vector-length vec)
  992.                                          callee)
  993.                        1)))))))
  994.  
  995. ;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp> [<start> <end>])
  996. ;;;       -> exact, nonnegative integer or #F
  997. ;;;     (CMP <value1> <value2>) -> integer
  998. ;;;       positive -> VALUE1 > VALUE2
  999. ;;;       zero     -> VALUE1 = VALUE2
  1000. ;;;       negative -> VALUE1 < VALUE2
  1001. ;;;   Perform a binary search through VECTOR for VALUE, comparing each
  1002. ;;;   element to VALUE with CMP.
  1003. (define (vector-binary-search vec value cmp . maybe-start+end)
  1004.   (let ((cmp (check-type procedure? cmp vector-binary-search)))
  1005.     (let-vector-start+end vector-binary-search vec maybe-start+end
  1006.                           (start end)
  1007.       (let loop ((start start) (end end) (j #f))
  1008.         (let ((i (quotient (+ start end) 2)))
  1009.           (if (or (= start end) (and j (= i j)))
  1010.               #f
  1011.               (let ((comparison
  1012.                      (check-type integer?
  1013.                                  (cmp (vector-ref vec i) value)
  1014.                                  `(,cmp for ,vector-binary-search))))
  1015.                 (cond ((zero?     comparison) i)
  1016.                       ((positive? comparison) (loop start i i))
  1017.                       (else                   (loop i end i))))))))))
  1018.  
  1019. ;;; (VECTOR-ANY <pred?> <vector> ...) -> value
  1020. ;;;   Apply PRED? to each parallel element in each VECTOR ...; if PRED?
  1021. ;;;   should ever return a true value, immediately stop and return that
  1022. ;;;   value; otherwise, when the shortest vector runs out, return #F.
  1023. ;;;   The iteration and order of application of PRED? across elements
  1024. ;;;   is of the vectors is strictly left-to-right.
  1025. (define vector-any
  1026.   (letrec ((loop1 (lambda (pred? vec i len len-1)
  1027.                     (and (not (= i len))
  1028.                          (if (= i len-1)
  1029.                              (pred? (vector-ref vec i))
  1030.                              (or (pred? (vector-ref vec i))
  1031.                                  (loop1 pred? vec (+ i 1)
  1032.                                         len len-1))))))
  1033.            (loop2+ (lambda (pred? vectors i len len-1)
  1034.                      (and (not (= i len))
  1035.                           (if (= i len-1)
  1036.                               (apply pred? (vectors-ref vectors i))
  1037.                               (or (apply pred? (vectors-ref vectors i))
  1038.                                   (loop2+ pred? vectors (+ i 1)
  1039.                                          len len-1)))))))
  1040.     (lambda (pred? vec . vectors)
  1041.       (let ((pred? (check-type procedure? pred? vector-any))
  1042.             (vec   (check-type vector?    vec   vector-any)))
  1043.         (if (null? vectors)
  1044.             (let ((len (vector-length vec)))
  1045.               (loop1 pred? vec 0 len (- len 1)))
  1046.             (let ((len (%smallest-length vectors
  1047.                                          (vector-length vec)
  1048.                                          vector-any)))
  1049.               (loop2+ pred? (cons vec vectors) 0 len (- len 1))))))))
  1050.  
  1051. ;;; (VECTOR-EVERY <pred?> <vector> ...) -> value
  1052. ;;;   Apply PRED? to each parallel value in each VECTOR ...; if PRED?
  1053. ;;;   should ever return #F, immediately stop and return #F; otherwise,
  1054. ;;;   if PRED? should return a true value for each element, stopping at
  1055. ;;;   the end of the shortest vector, return the last value that PRED?
  1056. ;;;   returned.  In the case that there is an empty vector, return #T.
  1057. ;;;   The iteration and order of application of PRED? across elements
  1058. ;;;   is of the vectors is strictly left-to-right.
  1059. (define vector-every
  1060.   (letrec ((loop1 (lambda (pred? vec i len len-1)
  1061.                     (or (= i len)
  1062.                         (if (= i len-1)
  1063.                             (pred? (vector-ref vec i))
  1064.                             (and (pred? (vector-ref vec i))
  1065.                                  (loop1 pred? vec (+ i 1)
  1066.                                         len len-1))))))
  1067.            (loop2+ (lambda (pred? vectors i len len-1)
  1068.                      (or (= i len)
  1069.                          (if (= i len-1)
  1070.                              (apply pred? (vectors-ref vectors i))
  1071.                              (and (apply pred? (vectors-ref vectors i))
  1072.                                   (loop2+ pred? vectors (+ i 1)
  1073.                                           len len-1)))))))
  1074.     (lambda (pred? vec . vectors)
  1075.       (let ((pred? (check-type procedure? pred? vector-every))
  1076.             (vec   (check-type vector?    vec   vector-every)))
  1077.         (if (null? vectors)
  1078.             (let ((len (vector-length vec)))
  1079.               (loop1 pred? vec 0 len (- len 1)))
  1080.             (let ((len (%smallest-length vectors
  1081.                                          (vector-length vec)
  1082.                                          vector-every)))
  1083.               (loop2+ pred? (cons vec vectors) 0 len (- len 1))))))))
  1084.  
  1085.  
  1086.  
  1087. ;;; --------------------
  1088. ;;; Mutators
  1089.  
  1090. ;;; (VECTOR-SET! <vector> <index> <value>) -> unspecified
  1091. ;;;   [R5RS] Assign the location at INDEX in VECTOR to VALUE.
  1092. (define vector-set! vector-set!)
  1093.  
  1094. ;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> unspecified
  1095. ;;;   Swap the values in the locations at INDEX1 and INDEX2.
  1096. (define (vector-swap! vec i j)
  1097.   (let ((vec (check-type vector? vec vector-swap!)))
  1098.     (let ((i (check-index vec i vector-swap!))
  1099.           (j (check-index vec j vector-swap!)))
  1100.       (let ((x (vector-ref vec i)))
  1101.         (vector-set! vec i (vector-ref vec j))
  1102.         (vector-set! vec j x)))))
  1103.  
  1104. ;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> unspecified
  1105. ;;;   [R5RS+] Fill the locations in VECTOR between START, whose default
  1106. ;;;   is 0, and END, whose default is the length of VECTOR, with VALUE.
  1107. ;;;
  1108. ;;; This one can probably be made really fast natively.
  1109. (define vector-fill!
  1110.   (let ((%vector-fill! vector-fill!))   ; Take the native one, under
  1111.                                         ;   the assumption that it's
  1112.                                         ;   faster, so we can use it if
  1113.                                         ;   there are no optional
  1114.                                         ;   arguments.
  1115.     (lambda (vec value . maybe-start+end)
  1116.       (if (null? maybe-start+end)
  1117.           (%vector-fill! vec value)     ;+++
  1118.           (let-vector-start+end vector-fill! vec maybe-start+end
  1119.                                 (start end)
  1120.             (do ((i start (+ i 1)))
  1121.                 ((= i end))
  1122.               (vector-set! vec i value)))))))
  1123.  
  1124. ;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>])
  1125. ;;;       -> unspecified
  1126. ;;;   Copy the values in the locations in [SSTART,SEND) from SOURCE to
  1127. ;;;   to TARGET, starting at TSTART in TARGET.
  1128. (define (vector-copy! target tstart source . maybe-sstart+send)
  1129.   (let* ((target (check-type vector? target vector-copy!))
  1130.          (tstart (check-index target tstart vector-copy!)))
  1131.     (let-vector-start+end vector-copy! source maybe-sstart+send
  1132.                           (sstart send)
  1133.       (let* ((source-length (vector-length source))
  1134.              (lose (lambda (argument)
  1135.                      (error "vector range out of bounds"
  1136.                             argument
  1137.                             `(while calling ,vector-copy!)
  1138.                             `(target was ,target)
  1139.                             `(target-length was ,(vector-length target))
  1140.                             `(tstart was ,tstart)
  1141.                             `(source was ,source)
  1142.                             `(source-length was ,source-length)
  1143.                             `(sstart was ,sstart)
  1144.                             `(send   was ,send)))))
  1145.         (cond ((< sstart 0)
  1146.                (lose '(sstart < 0)))
  1147.               ((< send 0)
  1148.                (lose '(send < 0)))
  1149.               ((> sstart send)
  1150.                (lose '(sstart > send)))
  1151.               ((>= sstart source-length)
  1152.                (lose '(sstart >= source-length)))
  1153.               ((> send source-length)
  1154.                (lose '(send > source-length)))
  1155.               (else
  1156.                (%vector-copy! target tstart
  1157.                               source sstart send)))))))
  1158.  
  1159. ;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>])
  1160. (define (vector-reverse-copy! target tstart source . maybe-sstart+send)
  1161.   (let* ((target (check-type vector? target vector-reverse-copy!))
  1162.          (tstart (check-index target tstart vector-reverse-copy!)))
  1163.     (let-vector-start+end vector-reverse-copy source maybe-sstart+send
  1164.                           (sstart send)
  1165.       (let* ((source-length (vector-length source))
  1166.              (lose (lambda (argument)
  1167.                      (error "vector range out of bounds"
  1168.                             argument
  1169.                             `(while calling ,vector-reverse-copy!)
  1170.                             `(target was ,target)
  1171.                             `(target-length was ,(vector-length target))
  1172.                             `(tstart was ,tstart)
  1173.                             `(source was ,source)
  1174.                             `(source-length was ,source-length)
  1175.                             `(sstart was ,sstart)
  1176.                             `(send   was ,send)))))
  1177.         (cond ((< sstart 0)
  1178.                (lose '(sstart < 0)))
  1179.               ((< send 0)
  1180.                (lose '(send < 0)))
  1181.               ((> sstart send)
  1182.                (lose '(sstart > send)))
  1183.               ((>= sstart source-length)
  1184.                (lose '(sstart >= source-length)))
  1185.               ((> send source-length)
  1186.                (lose '(send > source-length)))
  1187.               ((and (eq? target source)
  1188.                     (= sstart tstart))
  1189.                (%vector-reverse! target tstart send))
  1190.               ((and (eq? target source)
  1191.                     (or (between? sstart tstart send)
  1192.                         (between? tstart sstart
  1193.                                   (+ tstart (- send sstart)))))
  1194.                (error "vector range for self-copying overlaps"
  1195.                       vector-reverse-copy!
  1196.                       `(vector was ,target)
  1197.                       `(tstart was ,tstart)
  1198.                       `(sstart was ,sstart)
  1199.                       `(send   was ,send)))
  1200.               (else
  1201.                (%vector-reverse-copy! target tstart
  1202.                                       source sstart send)))))))
  1203.  
  1204. ;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> unspecified
  1205. ;;;   Destructively reverse the contents of the sequence of locations
  1206. ;;;   in VECTOR between START, whose default is 0, and END, whose
  1207. ;;;   default is the length of VECTOR.
  1208. (define (vector-reverse! vec . start+end)
  1209.   (let-vector-start+end vector-reverse! vec start+end
  1210.                         (start end)
  1211.     (%vector-reverse! vec start end)))
  1212.  
  1213.  
  1214.  
  1215. ;;; --------------------
  1216. ;;; Conversion
  1217.  
  1218. ;;; (VECTOR->LIST <vector> [<start> <end>]) -> list
  1219. ;;;   [R5RS+] Produce a list containing the elements in the locations
  1220. ;;;   between START, whose default is 0, and END, whose default is the
  1221. ;;;   length of VECTOR, from VECTOR.
  1222. (define vector->list
  1223.   (let ((%vector->list vector->list))
  1224.     (lambda (vec . maybe-start+end)
  1225.       (if (null? maybe-start+end)       ; Oughta use CASE-LAMBDA.
  1226.           (%vector->list vec)           ;+++
  1227.           (let-vector-start+end vector->list vec maybe-start+end
  1228.                                 (start end)
  1229.             ;(unfold (lambda (i)        ; No SRFI 1.
  1230.             ;          (< i start))
  1231.             ;        (lambda (i) (vector-ref vec i))
  1232.             ;        (lambda (i) (- i 1))
  1233.             ;        (- end 1))
  1234.             (do ((i (- end 1) (- i 1))
  1235.                  (result '() (cons (vector-ref vec i) result)))
  1236.                 ((< i start) result)))))))
  1237.  
  1238. ;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list
  1239. ;;;   Produce a list containing the elements in the locations between
  1240. ;;;   START, whose default is 0, and END, whose default is the length
  1241. ;;;   of VECTOR, from VECTOR, in reverse order.
  1242. (define (reverse-vector->list vec . maybe-start+end)
  1243.   (let-vector-start+end reverse-vector->list vec maybe-start+end
  1244.                         (start end)
  1245.     ;(unfold (lambda (i) (= i end))     ; No SRFI 1.
  1246.     ;        (lambda (i) (vector-ref vec i))
  1247.     ;        (lambda (i) (+ i 1))
  1248.     ;        start)
  1249.     (do ((i start (+ i 1))
  1250.          (result '() (cons (vector-ref vec i) result)))
  1251.         ((= i end) result))))
  1252.  
  1253. ;;; (LIST->VECTOR <list> [<start> <end>]) -> vector
  1254. ;;;   [R5RS+] Produce a vector containing the elements in LIST, which
  1255. ;;;   must be a proper list, between START, whose default is 0, & END,
  1256. ;;;   whose default is the length of LIST.  It is suggested that if the
  1257. ;;;   length of LIST is known in advance, the START and END arguments
  1258. ;;;   be passed, so that LIST->VECTOR need not call LENGTH to determine
  1259. ;;;   the the length.
  1260. ;;;
  1261. ;;; This implementation diverges on circular lists, unless LENGTH fails
  1262. ;;; and causes - to fail as well.  Given a LENGTH* that computes the
  1263. ;;; length of a list's cycle, this wouldn't diverge, and would work
  1264. ;;; great for circular lists.
  1265. (define list->vector
  1266.   (let ((%list->vector list->vector))
  1267.     (lambda (lst . maybe-start+end)
  1268.       ;; Checking the type of a proper list is expensive, so we do it
  1269.       ;; amortizedly, or let %LIST->VECTOR or LIST-TAIL do it.
  1270.       (if (null? maybe-start+end)       ; Oughta use CASE-LAMBDA.
  1271.           (%list->vector lst)           ;+++
  1272.           ;; We can't use LET-VECTOR-START+END, because we're using the
  1273.           ;; bounds of a _list_, not a vector.
  1274.           (let*-optionals maybe-start+end
  1275.               ((start 0)
  1276.                (end (length lst)))      ; Ugh -- LENGTH
  1277.             (let ((start (check-type nonneg-int? start list->vector))
  1278.                   (end   (check-type nonneg-int? end   list->vector)))
  1279.               ((lambda (f)
  1280.                  (vector-unfold f (- end start) (list-tail lst start)))
  1281.                (lambda (index l)
  1282.                  (cond ((null? l)
  1283.                         (error "list was too short"
  1284.                                `(list was ,lst)
  1285.                                `(attempted end was ,end)
  1286.                                `(while calling ,list->vector)))
  1287.                        ((pair? l)
  1288.                         (values (car l) (cdr l)))
  1289.                        (else
  1290.                         ;; Make this look as much like what CHECK-TYPE
  1291.                         ;; would report as possible.
  1292.                         (error "erroneous value"
  1293.                                ;; We want SRFI 1's PROPER-LIST?, but it
  1294.                                ;; would be a waste to link all of SRFI
  1295.                                ;; 1 to this module for only the single
  1296.                                ;; function PROPER-LIST?.
  1297.                                (list list? lst)
  1298.                                `(while calling
  1299.                                  ,list->vector))))))))))))
  1300.  
  1301. ;;; (REVERSE-LIST->VECTOR <list> [<start> <end>]) -> vector
  1302. ;;;   Produce a vector containing the elements in LIST, which must be a
  1303. ;;;   proper list, between START, whose default is 0, and END, whose
  1304. ;;;   default is the length of LIST, in reverse order.  It is suggested
  1305. ;;;   that if the length of LIST is known in advance, the START and END
  1306. ;;;   arguments be passed, so that REVERSE-LIST->VECTOR need not call
  1307. ;;;   LENGTH to determine the the length.
  1308. ;;;
  1309. ;;; This also diverges on circular lists unless, again, LENGTH returns
  1310. ;;; something that makes - bork.
  1311. (define (reverse-list->vector lst . maybe-start+end)
  1312.   (let*-optionals maybe-start+end
  1313.       ((start 0)
  1314.        (end (length lst)))              ; Ugh -- LENGTH
  1315.     (let ((start (check-type nonneg-int? start reverse-list->vector))
  1316.           (end   (check-type nonneg-int? end   reverse-list->vector)))
  1317.       ((lambda (f)
  1318.          (vector-unfold-right f (- end start) (list-tail lst start)))
  1319.        (lambda (index l)
  1320.          (cond ((null? l)
  1321.                 (error "list too short"
  1322.                        `(list was ,lst)
  1323.                        `(attempted end was ,end)
  1324.                        `(while calling ,reverse-list->vector)))
  1325.                ((pair? l)
  1326.                 (values (car l) (cdr l)))
  1327.                (else
  1328.                 (error "erroneous value"
  1329.                        (list list? lst)
  1330.                        `(while calling ,reverse-list->vector)))))))))
  1331.